home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / turtle.stk < prev    next >
Encoding:
Text File  |  1996-02-22  |  13.0 KB  |  562 lines
  1. #!/bin/sh
  2. :; exec /usr/local/bin/stk -f "$0" "$@"
  3. ;;;
  4. ;;; STkTurtle v1.0
  5. ;;; 
  6. ;;; A (direct) rewritting of the TkTurtle demo found on the net in STk.
  7. ;;; Original copyright:
  8. ;;;         Copyright 1993 James Noble, kjx@comp.vuw.ac.nz
  9. ;;;
  10.  
  11. ;;; This file comports two distinct parts. 
  12. ;;;    First part is the turtle package 
  13. ;;;    Second parts contains a set of examples using the turtle package
  14.  
  15.  
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. ;;;;
  18. ;;;; T u r t l e   p a c k a g e 
  19. ;;;;
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21.  
  22. (define turtle-canvas-name     ".c")
  23. (define turtle-canvas          '())
  24.  
  25. (define turtle-colours         #("" "root_weave" "stipple" "gray1" "boxes" 
  26.                   "hlines2" "vlines2" "cross_weave" 
  27.                   "light_gray" "dimple1" "vlines3" "hlines3" 
  28.                   "grid4" "gray3" "dimple3" "grid8"))
  29.  
  30. (define turtle-num_colours 16)
  31.  
  32. (define turtle-d2r    (/ 180 3.14159))
  33.  
  34. (define turtle-x        0)
  35. (define turtle-y        0)
  36. (define turtle-direction     270)
  37. (define turtle-width         0)
  38. (define turtle-colour         0)
  39. (define turtle-pen         #t)
  40.  
  41. (define turtle-speed        #t)
  42. (define turtle-show        #t)
  43.  
  44.  
  45. ;;;
  46. ;;; initialise turtle
  47. ;;;
  48. (define (turtle)
  49.   ;;  clear actually does this, plus draw-turtle
  50.   (set! turtle-x      0)
  51.   (set! turtle-y      0)
  52.   (set! turtle-direction 270)
  53.   (set! turtle-width      0)
  54.   (set! turtle-colour      0)
  55.   (set! turtle-pen      #t)
  56.  
  57.   ;;  debugging
  58.   (set! turtle-speed     #t)
  59.   (set! turtle-show     #t)
  60.  
  61.   (if (winfo 'exists turtle-canvas-name)
  62.       (new)
  63.       (begin
  64.     (scrollbar ".v" :relief "sunken" :borderwidth 3 
  65.                 :command (lambda l (apply turtle-canvas 'yview l)))
  66.     (scrollbar ".h" :relief "sunken" :borderwidth 3 
  67.                 :orient 'horiz :command (lambda l 
  68.                           (apply turtle-canvas 'xview l)))
  69.   
  70.     (canvas turtle-canvas-name :borderwidth     3 
  71.                    :scrollregion    '(-1000 -1000 1000 1000)
  72.                    :xscrollcommand  (lambda l (apply .h 'set l))
  73.                    :yscrollcommand  (lambda l (apply .v 'set l))
  74.                    :height          500 
  75.                    :width           500)
  76.     
  77.     (set! turtle-canvas (string->widget turtle-canvas-name))
  78.  
  79.     (centre)
  80.   
  81.     (pack .h :side "bottom" :fill "x")
  82.     (pack .v :side "right"  :fill "y")
  83.     (pack turtle-canvas :expand #t :fill "both")
  84.  
  85.  
  86.     (bind turtle-canvas "<2>"         (lambda (x y)
  87.                         (turtle-canvas 'scan 'mark x y)))
  88.     (bind turtle-canvas "<B2-Motion>" (lambda (x y)
  89.                         (turtle-canvas 'scan 'dragto x y)))
  90.     (bind turtle-canvas "<c>"       centre)
  91.     (bind turtle-canvas "<Control-c>" (lambda () (destroy ".")))
  92.     (bind turtle-canvas "<Control-q>" (lambda () (destroy ".")))
  93.     (bind turtle-canvas "<f>"         toggle-speed)
  94.     (bind turtle-canvas "<s>"      toggle-show)
  95.     
  96.     (focus turtle-canvas)
  97.  
  98.     (wm 'minsize    "." 10 10)
  99.     (wm 'title      "." "Turtle")
  100.     (wm 'iconname   "." "Turtle")
  101.  
  102.     (draw-turtle))))
  103.  
  104. ;;;
  105. ;;;  drawing
  106. ;;;
  107.  
  108. (define (make-stipple n)
  109.   (let ((name (vector-ref turtle-colours n)))
  110.     (if (string=? name "")
  111.     ""
  112.     (string-append "@" *STk-library* "/images/" name))))
  113.  
  114. (define (go length)
  115.   (let ((newx (+ turtle-x (* (cos (/ turtle-direction turtle-d2r)) length)))
  116.     (newy (+ turtle-y (* (sin (/ turtle-direction turtle-d2r)) length))))
  117.  
  118.     (goto newx newy)
  119.     length))
  120.  
  121. (define (goto x y)
  122.   (when turtle-pen
  123.      (turtle-canvas 'create 'line turtle-x turtle-y x y 
  124.             :width turtle-width 
  125.             :stipple (make-stipple turtle-colour)
  126.             :tags 'line))
  127.  
  128.   (set! turtle-x x)
  129.   (set! turtle-y y)
  130.   (when turtle-show  (draw-turtle))
  131.   (when turtle-speed (update))
  132.   (list x y))
  133.  
  134.  
  135. ;;;  writing text
  136. (define (Write text)
  137.   (turtle-canvas 'create 'text turtle-x turtle-y 
  138.          :text text 
  139.          :stipple (make-stipple turtle-colour)
  140.          :tags 'text)
  141.   (when turtle-speed (update)))
  142.  
  143.  
  144. ;;;  writing windows
  145. (define (window name)
  146.   (turtle-canvas 'create 'window turtle-x turtle-y 
  147.          :window name
  148.          :tags 'window)
  149.   (update))
  150.  
  151. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  152. ;;; drawing parameters
  153. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  154.  
  155. ;; change pen state
  156. (define (pen . p)
  157.   (if (null? p)
  158.       turtle-pen
  159.       (set! turtle-pen (car p))))
  160.  
  161. (define (down) (pen #t))
  162. (define (up)   (pen #f))
  163.  
  164.  
  165. ;;; change direction
  166. (define (turn n)
  167.   (turnto (+ turtle-direction n)))
  168.  
  169. (define (turnto n)
  170.   (set! turtle-direction (modulo (floor n) 360))
  171.   (draw-turtle)
  172.   turtle-direction)
  173.  
  174. (define (east)  (turnto 0))
  175. (define (south) (turnto 90))
  176. (define (west)  (turnto 180))
  177. (define (north) (turnto 270))
  178.  
  179. (define (direction) 
  180.   turtle-direction)
  181.  
  182. (define (location)
  183.   (list turtle-x turtle-y))
  184.  
  185. (define (width . w)
  186.   (unless (null? w)
  187.      (set! turtle-width (car w))
  188.      (draw-turtle))
  189.   turtle-width)
  190.  
  191. (define (colour . c)
  192.   (if (null? c) 
  193.       turtle-colour
  194.       (set! turtle-colour (modulo (floor (car c)) turtle-num_colours))))
  195.  
  196. (define (status . c)
  197.   (if (null? c)
  198.       (list turtle-x turtle-y turtle-direction turtle-width turtle-colour 
  199.         turtle-pen)
  200.       (if (not (= (length (car c)) 6))
  201.       (error "Can't restore saved state")
  202.       (let ((c (car c)))
  203.         (set! turtle-x         (list-ref c 0))
  204.         (set! turtle-y         (list-ref c 1))
  205.         (set! turtle-direction (list-ref c 2))
  206.         (set! turtle-width     (list-ref c 3))
  207.         (set! turtle-colour    (list-ref c 4))
  208.         (set! turtle-pen       (list-ref c 5))
  209.         (draw-turtle)
  210.         c))))
  211.  
  212. (define (draw-turtle)
  213.   (when turtle-show
  214.      (turtle-canvas 'delete 'turtle)
  215.      (turtle-canvas 'create 'line 
  216.             turtle-x 
  217.             turtle-y 
  218.             (+ turtle-x (* (cos (/ turtle-direction turtle-d2r)) 10))
  219.             (+ turtle-y (* (sin (/ turtle-direction turtle-d2r)) 10))
  220.             :arrow 'last 
  221.             :fill  "red"
  222.             :tags 'turtle 
  223.             :width turtle-width))
  224.   0)
  225.  
  226. (define (show)
  227.   (set! turtle-show #t)
  228.   (draw-turtle)
  229.   #t)
  230.  
  231. (define (hide)
  232.    (set! turtle-show #f)
  233.    (turtle-canvas 'delete 'turtle)
  234.    #f)
  235.  
  236. (define (toggle-show)
  237.   (if turtle-show (hide) (show)))
  238.  
  239.  
  240. ;;; misc
  241. (define (home)
  242.   (set! turtle-x 0)
  243.   (set! turtle-y 0)
  244.   (set! turtle-direction 270)
  245.   (draw-turtle))
  246.  
  247. (define (clear)
  248.   (home)
  249.   (down)
  250.   (width 0)
  251.   (colour 0)
  252.   (turtle-canvas 'delete 'line 'text)
  253.   (draw-turtle))
  254.  
  255. (define (new)
  256.   (clear)
  257.   (turtle-canvas 'delete 'window))
  258.  
  259. (define (screen-dump . file)
  260.   (turtle-canvas 'postscript 
  261.          :file (if (null? file) "Screen-dump.ps" (car file))))
  262.  
  263. (define (centre)
  264.   (turtle-canvas 'xview 'moveto 0.37)
  265.   (turtle-canvas 'yview 'moveto 0.37))
  266.  
  267.  
  268. ;;;conversion
  269. (define (d2r degrees)
  270.   (/ degrees turtle-d2r))
  271.  
  272. ;;; speed
  273. (define (speed . s)
  274.   (if (null? s) 
  275.       turtle-speed
  276.       (set! turtle-speed (car s))))
  277.  
  278. (define (slow) (speed #t))
  279. (define (fast) (speed #f))
  280. (define (toggle-speed) (if turtle-speed (fast) (slow)))
  281.  
  282. ;;; MACROS - move, moveto
  283. (define (move distance)
  284.   (let ((oldpen (pen)))
  285.     (go distance)
  286.     (pen oldpen)))
  287.  
  288. (define (moveto x y)
  289.   (let ((oldpen (pen)))
  290.     (goto x y)
  291.     (pen oldpen)))
  292.  
  293.  
  294. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  295. ;;;;
  296. ;;;; E x a m p l e s
  297. ;;;;
  298. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  299.  
  300.  
  301. ;; polygon
  302. (define (polygon n length)
  303.   (do ((k 0 (+ k 1)))
  304.       ((= k n))
  305.     (turn (/ 360 n))
  306.     (go length)))
  307.  
  308. ;; polygon, with a functional parameter 
  309. (define (fungon n length F)
  310.   (do ((k 0 (+ k 1)))
  311.       ((= k n))
  312.     (turn (/ 360 n))
  313.     (F length)))
  314.  
  315. ;; Iterative Spiral
  316. (define (spiral angle length)
  317.   (while (>= length 1)
  318.      (go length)
  319.      (turn angle)
  320.      (set! length (- length 5))))
  321.  
  322. ;; Recursive spiral
  323. (define (rspiral angle length)
  324.   (when (>= length 1)
  325.     (go length)
  326.     (turn angle)
  327.     (rspiral angle (- length 5))))
  328.  
  329. ;; "Koch's" a single line - used in snowflake
  330. (define (koch order length)
  331.   (if (or (<= order  1) (<= length 1))
  332.       (go length)
  333.       (begin
  334.     (koch (- order 1) (/ length 3))
  335.     (turn -60)
  336.     (koch (- order 1) (/ length 3))
  337.     (turn 120)
  338.     (koch (- order 1) (/ length 3))
  339.     (turn -60)
  340.     (koch (- order 1) (/ length 3)))))
  341.  
  342. ;; Koch's snowflake fractal
  343. (define (kochflake order length)
  344.   (do ((k 0 (+ k 1)))
  345.       ((= k 3))
  346.     (turn 120)
  347.     (koch order length)))
  348.  
  349. ;; tricky version of kochflake
  350. (define (tricky-kochflake order length)
  351.   (fungon 3 (lambda () (koch order length))))
  352.  
  353. ;; Four sided koch 
  354. (define (squarekoch order length)
  355.   (if (or (<= order 1) (<= length 1))
  356.       (go length)
  357.       (begin
  358.     (squarekoch (- order 1) (/ length 3))
  359.     (turn -90)
  360.     (squarekoch (- order 1) (/ length 3))
  361.     (turn 90)
  362.     (squarekoch (- order 1) (/ length 3))
  363.     (turn 90)
  364.     (squarekoch (- order 1) (/ length 3))
  365.     (turn -90)
  366.     (squarekoch (- order 1) (/ length 3)))))
  367.  
  368. (define (squareflake order length)
  369.   (do ((k 0 (+ k 1)))
  370.       ((= k 4))
  371.     (turn 90)
  372.     (squarekoch order length)))
  373.  
  374. ;; Fractal line
  375. (define (fracline order angle length)
  376.   (if (< order 1)
  377.       (go length)
  378.       (let* ((ang  (- [random (* 2 angle)] angle))
  379.          (len  (/ length (* 2 [cos (d2r ang)]))))
  380.     (turn ang)
  381.     (fracline (- order 1) angle len)
  382.     (turn (- (* ang 2)))
  383.     (fracline (- order 1) angle len)
  384.     (turn ang))))
  385.  
  386. ;; binary tree
  387. (define (bintree depth length angle)
  388.   (when (> depth 0)
  389.     (let ((saved (status)))
  390.       (set! depth (- depth 1))
  391.       (go length)
  392.       (turn (- angle))
  393.       (bintree depth length angle)
  394.       (turn (+ angle 2))
  395.       (bintree depth length angle)
  396.       (status saved))))
  397.  
  398. ;; C curve fractal
  399. (define (ccurv order length)
  400.   (if (<= order 1) 
  401.       (go length)
  402.       (begin
  403.     (ccurv (- order 1) length)
  404.     (turn 90)
  405.     (ccurv (- order 1) length)
  406.     (turn -90))))
  407.  
  408. ;; Dragon curve fractal
  409. (define (dragon order length)
  410.   (letrec ((dragon-aux (lambda (order length dirn)
  411.              (if (<= order 1) 
  412.                  (go length)
  413.                  (begin
  414.                    (dragon-aux (- order 1) length 90)
  415.                    (turn dirn)
  416.                    (dragon-aux (- order 1) length -90))))))
  417.     (dragon-aux order length 90)))
  418.  
  419. ;; Sierpinski's gasket
  420. (define (gasket order length)
  421.   (when (> order  0)
  422.     (do ((k 0 (+ k 1)))
  423.         ((= k 3))
  424.       (gasket (- order 1)  (/ length 2))
  425.       (go length)
  426.       (turn 120))))
  427.  
  428. ;; Sierpinski's carpet
  429. (define (carpet order length)
  430.   (if (< order 1)
  431.       (go length)
  432.       (begin
  433.     (carpet (- order 1) (/ length 3))
  434.     (turn -90)
  435.     (carpet (- order 1) (/ length 3))
  436.     (turn 90)
  437.     (carpet (- order 1) (/ length 3))
  438.     (turn 90)
  439.     (carpet (- order 1) (/ length 3))
  440.     (let ((saved (status)))
  441.       (carpet (- order 1) (/ length 3))
  442.       (turn 90)
  443.       (carpet (- order 1) (/ length 3))
  444.       (turn 90)
  445.       (carpet (- order 1) (/ length 3))
  446.       (status saved)
  447.       (turn -90)
  448.       (carpet (- order 1) (/ length 3))))))
  449.  
  450. ;; "Bendy" - simple fractal (C curve  variation)
  451. (define (bendy order length)
  452.   (if  (< order 1)
  453.        (go length)
  454.        (begin
  455.      (turn 30)
  456.      (bendy (- order 1) (/ length 2))
  457.      (turn -60)
  458.      (bendy (- order 1) (/ length 2))
  459.      (turn 30))))
  460.  
  461. ;; "Squigly" - simple fractal (C curve variation)
  462. (define (squigly order length)
  463.   (if  (< order 1)
  464.        (go length)
  465.        (begin
  466.      (turn 30)
  467.      (squigly (- order 1) (/ length 4))
  468.      (turn -60)
  469.      (squigly (- order 1) (/ length 2))
  470.      (turn 60)
  471.      (squigly (- order 1) (/ length 4))
  472.      (turn -30))))
  473.  
  474. (define (randtree depth length angle branch)
  475.   (when (>= depth 1)
  476.     (let ((saved (status))
  477.           (thisbranch (random branch)))
  478.       (set! depth (- depth 1))
  479.       (go (+ (random length) length))
  480.       (turn (- (/ (* angle thisbranch) 4)))
  481.       (do ((k 0 (+ k 1)))
  482.           ((= k thisbranch))
  483.         (turn (random angle))
  484.         (randtree depth length angle branch))
  485.       (status saved))))
  486.  
  487. ;;windows-demo
  488. (define (windows-demo)
  489.   (let ((S (scale (& turtle-canvas "scale"))))
  490.     (show)
  491.     (up)
  492.     (goto -200 -200)
  493.     (window S)
  494.     (goto -150 -200)
  495.     (window (button (& turtle-canvas ".spiral-button") :text "Spiral"
  496.             :command (lambda () (spiral [S 'get] 100))))
  497.     (goto -100 -200)
  498.     (window [button (& turtle-canvas ".clear-button") :text "Clear" :command clear])
  499.     (goto -50 -200)
  500.     (window [button (& turtle-canvas ".home-button") :text "Home" :command home])
  501.     (goto 180 -200)
  502.     (window [button (& turtle-canvas ".quit-button") :text "Quit Demo" 
  503.             :fg "CadetBlue" :command (lambda () (exit))])
  504.     (S 'set 45)
  505.     (down)
  506.     (home)))
  507.  
  508. (define (item message demo)
  509.   (clear)
  510.   (up)
  511.   (goto 0 220)
  512.   (down)
  513.   (Write message)
  514.   (home)
  515.   (demo))
  516.  
  517. (define (run-demo)
  518.   (item "Polygon" 
  519.     (lambda () 
  520.       (do ((k 3 (+ k 1))) ((= k 12))
  521.         (home) (polygon k 50))))
  522.   (item "Lines"   
  523.     (lambda ()
  524.       (do ((k 0 (+ k 1))) ((= k 16))
  525.         (moveto 0 0) (turn 22.5) (width k) (go 200))))
  526.  
  527.   (item "Stipple"
  528.     (lambda () 
  529.       (width 15)
  530.       (do ((k 0 (+ k 1))) ((= k 16))
  531.         (moveto 0 0) (turn 22.5) (colour k) (go 200))))
  532.  
  533.   (item "Fractal lines"    
  534.     (lambda () 
  535.       (do ((k 0 (+ k 1))) ((= k 7))
  536.         (home) (fracline 6 40 200))))
  537.  
  538.   (item "Spiral"           (lambda () (spiral 50 100)))
  539.   (item "Recursive spiral" (lambda () (rspiral 89 100)))
  540.   (item "Recursive spiral" (lambda () (rspiral -90 100)))
  541.   (item "Koch flake"       (lambda () (kochflake 3 150)))
  542.   (item "Square flake"     (lambda () (squareflake 3 150)))
  543.   (item "Squigly"       (lambda () (squigly 4 200)))
  544.   (item "C curve"          (lambda () (ccurv 6 20)))
  545.   (item "Dragon"       (lambda () (dragon 6 20)))
  546.   (item "Gasket"       (lambda () (gasket 6 200)))
  547.   (item "Carpet"       (lambda () (carpet 3 250)))
  548.   (item "Binary tree"       (lambda () (bintree 6 30 20)))
  549.   (item "Random tree"       (lambda () (randtree 4 20 30 6)))
  550.   (item "Windows Demo"     windows-demo))
  551.  
  552.  
  553.  
  554. ;; Init part - Run the demo
  555. (expand-heap 50000)
  556. (set! *gc-verbose* #f)
  557.  
  558. (turtle)
  559. (hide)
  560.  
  561. (run-demo)
  562.